home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / COMAL / L-PET COMAL / (k)l1.d64 / evaluator.l < prev    next >
Text File  |  2007-03-01  |  6KB  |  284 lines
  1. 0010 //
  2. 0020 // EXPRESSION EVALUATION
  3. 0030 //
  4. 0040 REPEAT 
  5. 0050 ENTER'EXPR("ENTER EXPRESSION",X)
  6. 0060 PRINT "THE VALUE IS";X
  7. 0070 PRINT 
  8. 0080 UNTIL FALSE
  9. 0090 HALT
  10. 0100 //
  11. 0110 PROC ENTER'EXPR(PROMPT$,REF VALUE) CLOSED
  12. 0120 DIM TEXT$ OF 80
  13. 0130 REPEAT  // UNTIL LEGAL EXPRESSION //
  14. 0140 ERR:=FALSE
  15. 0150 REPEAT  // DON'T ACCEPT A NULL STRING
  16. 0160 INPUT PROMPT$+": ": TEXT$
  17. 0170 UNTIL TEXT$>""
  18. 0180 IF TEXT$="STOP" THEN
  19. 0190 HALT
  20. 0200 ELSE 
  21. 0210 VALUE:=EXPRESSION(TEXT$,ERR)
  22. 0220 ENDIF 
  23. 0230 UNTIL NOT ERR
  24. 0240 ENDPROC ENTER'EXPR
  25. 0250 //
  26. 0260 FUNC EXPRESSION(TEXT$,REF ERR) CLOSED
  27. 0270 //
  28. 0280 DUMMY:=1
  29. 0290 //
  30. 0300 DIM EXPR$ OF LEN(TEXT$)+1, EOL$ OF 1
  31. 0310 DIM SYMBOL$ OF 10, CHAR$ OF 1
  32. 0320 //
  33. 0330 EOL$:=CHR$(13)
  34. 0340 EXPR$:=TEXT$+EOL$
  35. 0350 I:=1
  36. 0360 PI:=ATN(1)*4
  37. 0370 //
  38. 0380 NEXT'CHAR
  39. 0390 NEXT'SYMBOL
  40. 0400 VALUE:=SIMPLE'EXPR(DUMMY)
  41. 0410 MUSTBE(EOL$)
  42. 0420 //
  43. 0430 RETURN VALUE
  44. 0440 //
  45. 0450 ENDFUNC EXPRESSION
  46. 0460 //
  47. 0470 FUNC SIMPLE'EXPR(VALUE) 
  48. 0480 IF SYMBOL$ IN "+-" THEN
  49. 0490 VALUE:=0
  50. 0500 ELSE 
  51. 0510 VALUE:=TERM(DUMMY)
  52. 0520 ENDIF 
  53. 0530 WHILE SYMBOL$ IN "+-" DO
  54. 0540 IF SYMBOL$="+" THEN
  55. 0550 NEXT'SYMBOL; VALUE:+TERM(DUMMY)
  56. 0560 ELSE 
  57. 0570 NEXT'SYMBOL; VALUE:-TERM(DUMMY)
  58. 0580 ENDIF 
  59. 0590 ENDWHILE 
  60. 0600 RETURN VALUE
  61. 0610 ENDFUNC SIMPLE'EXPR
  62. 0620 //
  63. 0630 FUNC TERM(VALUE) 
  64. 0640 VALUE:=FACTOR(DUMMY)
  65. 0650 WHILE SYMBOL$ IN "*/" DO
  66. 0660 IF SYMBOL$="*" THEN
  67. 0670 NEXT'SYMBOL; VALUE:=VALUE*FACTOR(DUMMY)
  68. 0680 ELSE 
  69. 0690 NEXT'SYMBOL; VALUE:=VALUE/FACTOR(DUMMY)
  70. 0700 ENDIF 
  71. 0710 ENDWHILE 
  72. 0720 RETURN VALUE
  73. 0730 ENDFUNC TERM
  74. 0740 //
  75. 0750 FUNC FACTOR(VALUE) 
  76. 0760 VALUE:=OPERAND(DUMMY)
  77. 0770 IF HAVE("^") THEN
  78. 0780 RETURN VALUE^FACTOR(DUMMY)
  79. 0790 ELSE 
  80. 0800 RETURN VALUE
  81. 0810 ENDIF 
  82. 0820 ENDFUNC FACTOR
  83. 0830 //
  84. 0840 FUNC OPERAND(VALUE) 
  85. 0850 IF HAVE("<NUMBER>") THEN
  86. 0860 RETURN NUMBER
  87. 0870 ELIF HAVE("(") THEN
  88. 0880 VALUE:=SIMPLE'EXPR(DUMMY); MUSTBE(")")
  89. 0890 RETURN VALUE
  90. 0900 ELIF "A"<=SYMBOL$(1) AND SYMBOL$(1)<="Z" THEN
  91. 0910 RETURN FUNCTION'CALL(DUMMY)
  92. 0920 ELSE 
  93. 0930 ERROR("OPERAND EXPECTED")
  94. 0940 RETURN DUMMY
  95. 0950 ENDIF 
  96. 0960 ENDFUNC OPERAND
  97. 0970 //
  98. 0980 PROC MUSTBE(TOKEN$) 
  99. 0990 IF TOKEN$=SYMBOL$ THEN
  100. 1000 NEXT'SYMBOL
  101. 1010 ELIF TOKEN$=EOL$ THEN
  102. 1020 ERROR(""""+SYMBOL$+""" NOT EXPECTED")
  103. 1030 ELIF SYMBOL$=EOL$ THEN
  104. 1040 ERROR(""""+TOKEN$+""" EXPECTED")
  105. 1050 ELSE 
  106. 1060 ERROR(""""+TOKEN$+""" EXPECTED, NOT """+SYMBOL$+"""")
  107. 1070 ENDIF 
  108. 1080 ENDPROC MUSTBE
  109. 1090 //
  110. 1100 FUNC HAVE(TOKEN$) 
  111. 1110 IF TOKEN$=SYMBOL$ THEN
  112. 1120 NEXT'SYMBOL
  113. 1130 RETURN TRUE
  114. 1140 ELSE 
  115. 1150 RETURN FALSE
  116. 1160 ENDIF 
  117. 1170 ENDFUNC HAVE
  118. 1180 //
  119. 1190 PROC ERROR(MESSAGE$) 
  120. 1200 IF NOT ERR THEN
  121. 1210 PRINT 
  122. 1220 PRINT TEXT$
  123. 1230 PRINT TAB(I'-1),"^"
  124. 1240 PRINT "*** ",MESSAGE$," ***"
  125. 1250 PRINT 
  126. 1260 ERR:=TRUE
  127. 1270 ENDIF 
  128. 1280 ENDPROC ERROR
  129. 1290 //
  130. 1300 PROC NEXT'SYMBOL 
  131. 1310 WHILE CHAR$=" " DO NEXT'CHAR
  132. 1320 I':=I
  133. 1330 IF CHAR$ IN "0123456789." THEN
  134. 1340 NUMBER:=VAL; SYMBOL$:="<NUMBER>"
  135. 1350 ELIF "A"<=CHAR$ AND CHAR$<="Z" THEN
  136. 1360 GET'IDENTIFIER
  137. 1370 ELSE 
  138. 1380 SYMBOL$:=CHAR$; NEXT'CHAR
  139. 1390 ENDIF 
  140. 1400 ENDPROC NEXT'SYMBOL
  141. 1410 //
  142. 1420 FUNC VAL  // PARSE NUMBER AND RETURN VALUE
  143. 1430 X:=0 // ACCUMULATE IN X
  144. 1440 IF CHAR$="." THEN
  145. 1450 NEXT'CHAR
  146. 1460 I'':=I; POS:=10
  147. 1470 WHILE "0"<=CHAR$ AND CHAR$<="9" DO
  148. 1480 X:+(ORD(CHAR$)-ORD("0"))/POS; POS:=POS*10; NEXT'CHAR
  149. 1490 ENDWHILE 
  150. 1500 IF I''=I THEN ERROR("FORMAT ERROR IN NUMBER")
  151. 1510 SCALE'FACTOR
  152. 1520 ELSE 
  153. 1530 WHILE "0"<=CHAR$ AND CHAR$<="9" DO
  154. 1540 X:=X*10+ORD(CHAR$)-ORD("0"); NEXT'CHAR
  155. 1550 ENDWHILE 
  156. 1560 IF CHAR$="." THEN
  157. 1570 NEXT'CHAR
  158. 1580 POS:=10
  159. 1590 WHILE "0"<=CHAR$ AND CHAR$<="9" DO
  160. 1600 X:+(ORD(CHAR$)-ORD("0"))/POS; POS:=POS*10; NEXT'CHAR
  161. 1610 ENDWHILE 
  162. 1620 ENDIF 
  163. 1630 SCALE'FACTOR
  164. 1640 ENDIF 
  165. 1650 RETURN X
  166. 1660 ENDFUNC VAL
  167. 1670 //
  168. 1680 PROC SCALE'FACTOR 
  169. 1690 IF CHAR$="E" THEN
  170. 1700 NEXT'CHAR
  171. 1710 IF CHAR$ IN "+-" THEN
  172. 1720 SIGN:=(CHAR$="+")-(CHAR$="-"); NEXT'CHAR
  173. 1730 ELSE 
  174. 1740 SIGN:=1
  175. 1750 ENDIF 
  176. 1760 I'':=I; EXPO:=0
  177. 1770 WHILE "0"<=CHAR$ AND CHAR$<="9" DO
  178. 1780 EXPO:=EXPO*10+ORD(CHAR$)-ORD("0"); NEXT'CHAR
  179. 1790 ENDWHILE 
  180. 1800 IF I''=I THEN ERROR("EXPONENT ERROR IN NUMBER")
  181. 1810 X:=X*10^(SIGN*EXPO)
  182. 1820 ENDIF 
  183. 1830 ENDPROC SCALE'FACTOR
  184. 1840 //
  185. 1850 PROC GET'IDENTIFIER 
  186. 1860 WHILE "A"<=CHAR$ AND CHAR$<="Z" DO NEXT'CHAR
  187. 1870 SYMBOL$:=EXPR$(I'-1:I-2)
  188. 1880 ENDPROC GET'IDENTIFIER
  189. 1890 //
  190. 1900 PROC NEXT'CHAR 
  191. 1910 IF I<=LEN(EXPR$) THEN
  192. 1920 CHAR$:=EXPR$(I)
  193. 1930 ELSE 
  194. 1940 CHAR$:=EOL$
  195. 1950 ENDIF 
  196. 1960 I:+1
  197. 1970 ENDPROC NEXT'CHAR
  198. 1980 //
  199. 1990 PROC HALT  // HALT PROGRAM EXECUTION
  200. 2000 CLOSE
  201. 2010 END 
  202. 2020 ENDPROC HALT
  203. 2030 //
  204. 2040 FUNC FUNCTION'CALL(VALUE) 
  205. 2050 CASE SYMBOL$ OF
  206. 2060 WHEN "PI"
  207. 2070 NEXT'SYMBOL
  208. 2080 RETURN PI
  209. 2090 WHEN "E"
  210. 2100 NEXT'SYMBOL
  211. 2110 RETURN EXP(1)
  212. 2120 WHEN "SIN"
  213. 2130 RETURN SIN(RAD(PARAMETER))
  214. 2140 WHEN "COS"
  215. 2150 RETURN COS(RAD(PARAMETER))
  216. 2160 WHEN "TAN"
  217. 2170 RETURN TAN(RAD(PARAMETER))
  218. 2180 WHEN "RAD"
  219. 2190 RETURN RAD(PARAMETER)
  220. 2200 WHEN "DEG"
  221. 2210 RETURN DEG(PARAMETER)
  222. 2220 WHEN "SQRT"
  223. 2230 RETURN SQR(PARAMETER)
  224. 2240 WHEN "LN"
  225. 2250 RETURN LOG(PARAMETER)
  226. 2260 WHEN "LOG"
  227. 2270 RETURN LOG(PARAMETER)/LOG(10)
  228. 2280 WHEN "ARCSIN"
  229. 2290 RETURN DEG(ARCSIN(PARAMETER))
  230. 2300 WHEN "ARCCOS"
  231. 2310 RETURN DEG(ARCCOS(PARAMETER))
  232. 2320 WHEN "ARCTAN"
  233. 2330 RETURN DEG(ATN(PARAMETER))
  234. 2340 WHEN "EXP"
  235. 2350 RETURN EXP(PARAMETER)
  236. 2360 OTHERWISE 
  237. 2370 ERROR("UNKNOWN IDENTIFIER")
  238. 2380 RETURN DUMMY
  239. 2390 ENDCASE 
  240. 2400 ENDFUNC FUNCTION'CALL
  241. 2410 //
  242. 2420 FUNC RAD(X) 
  243. 2430 RETURN X/180*PI
  244. 2440 ENDFUNC RAD
  245. 2450 //
  246. 2460 FUNC DEG(X) 
  247. 2470 RETURN X/PI*180
  248. 2480 ENDFUNC DEG
  249. 2490 //
  250. 2500 FUNC PARAMETER 
  251. 2510 NEXT'SYMBOL
  252. 2520 MUSTBE("(")
  253. 2530 VALUE:=SIMPLE'EXPR(DUMMY)
  254. 2540 MUSTBE(")")
  255. 2550 RETURN VALUE
  256. 2560 ENDFUNC PARAMETER
  257. 2570 //
  258. 2580 FUNC ARCSIN(X) 
  259. 2590 IF ABS(X)=1 THEN
  260. 2600 RETURN PI/2*SGN(X)
  261. 2610 ELIF ABS(X)>1 THEN
  262. 2620 ARG'ERROR
  263. 2630 RETURN DUMMY
  264. 2640 ELSE 
  265. 2650 RETURN ATN(X/SQR(1-X*X))
  266. 2660 ENDIF 
  267. 2670 ENDFUNC ARCSIN
  268. 2680 //
  269. 2690 FUNC ARCCOS(X) 
  270. 2700 IF X=0 THEN
  271. 2710 RETURN PI/2
  272. 2720 ELIF ABS(X)>1 THEN
  273. 2730 ARG'ERROR
  274. 2740 RETURN DUMMY
  275. 2750 ELSE 
  276. 2760 RETURN ATN(SQR(1-X*X)/X)+(X<0)*PI
  277. 2770 ENDIF 
  278. 2780 ENDFUNC ARCCOS
  279. 2790 //
  280. 2800 PROC ARG'ERROR 
  281. 2810 ERROR("ILLEGAL FUNCTION ARGUMENT")
  282. 2820 ENDPROC ARG'ERROR
  283. 2830 //
  284.